home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
AmigActive 2
/
AACD 2.iso
/
AACD
/
Programming
/
fpc
/
compiler
/
pexpr.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1998-09-24
|
76KB
|
1,677 lines
{
$Id: pexpr.pas,v 1.2.2.1 1998/05/21 12:26:55 carl Exp $
Copyright (c) 1998 by Florian Klaempfl
Does parsing of expression for Free Pascal
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit pexpr;
interface
uses symtable,tree;
{ reads a whole expression }
function expr : ptree;
{ reads a single factor }
function factor(getaddr : boolean) : ptree;
{ the ID token has to be consumed before calling this function }
procedure do_member_read(const sym : psym;var p1 : ptree;
var pd : pdef;var again : boolean);
function get_intconst:longint;
function get_stringconst:string;
implementation
uses
cobjects,globals,scanner,aasm,pass_1,systems,
hcodegen,types,verbose
{ parser specific stuff }
,pbase,pdecl
{ processor specific stuff }
{$ifdef i386}
,i386
{$endif}
{$ifdef m68k}
,m68k
{$endif}
;
function parse_paras(_colon,in_prop_paras : boolean) : ptree;
var
p1,p2 : ptree;
end_of_paras : ttoken;
begin
if in_prop_paras then
end_of_paras:=RECKKLAMMER
else
end_of_paras:=RKLAMMER;
if token=end_of_paras then
begin
parse_paras:=nil;
exit;
end;
p2:=nil;
inc(parsing_para_level);
while true do
begin
p1:=expr;
p2:=gencallparanode(p1,p2);
{ it's for the str(l:5,s); }
if _colon and (token=COLON) then
begin
consume(COLON);
p1:=expr;
p2:=gencallparanode(p1,p2);
p2^.is_colon_para:=true;
if token=COLON then
begin
consume(COLON);
p1:=expr;
p2:=gencallparanode(p1,p2);
p2^.is_colon_para:=true;
end
end;
if token=COMMA then
consume(COMMA)
else
break;
end;
dec(parsing_para_level);
parse_paras:=p2;
end;
function statement_syssym(l : longint;var pd : pdef) : ptree;
{ const regnames:array[R_EAX..R_EDI] of string[3]=
('EAX','ECX','EDX','EBX','','','ESI','EDI'); }
var
p1,p2 : ptree;
paras : ptree;
prev_in_args : boolean;
Store_valid : boolean;
begin
prev_in_args:=in_args;
Store_valid:=Must_be_valid;
case l of
in_ord_x :
begin
consume(LKLAMMER);
in_args:=true;
Must_be_valid:=true;
p1:=expr;
consume(RKLAMMER);
do_firstpass(p1);
p1:=geninlinenode(in_ord_x,p1);
do_firstpass(p1);
statement_syssym := p1;
pd:=p1^.resulttype;
end;
in_typeof_x : begin
consume(LKLAMMER);
in_args:=true;
p1:=expr;
consume(RKLAMMER);
pd:=voidpointerdef;
if p1^.treetype=typen then
begin
if (p1^.resulttype=nil) then
begin
Message(sym_e_type_mismatch);
statement_syssym:=genzeronode(errorn);
end
else
if p1^.resulttype^.deftype=objectdef then
statement_syssym:=geninlinenode(in_typeof_x,p1)
else
begin
Message(sym_e_type_mismatch);
statement_syssym:=genzeronode(errorn);
end;
end
else
begin
Must_be_valid:=false;
do_firstpass(p1);
if (p1^.resulttype=nil) then
begin
Message(sym_e_type_mismatch);
statement_syssym:=genzeronode(errorn)
end
else
if p1^.resulttype^.deftype=objectdef then
statement_syssym:=geninlinenode(in_typeof_x,p1)
else
begin
Message(sym_e_type_mismatch);
statement_syssym:=genzeronode(errorn)
end;
end;
end;
in_sizeof_x : begin
consume(LKLAMMER);
in_args:=true;
p1:=expr;
consume(RKLAMMER);
pd:=s32bitdef;
if p1^.treetype=typen then
begin
statement_syssym:=genordinalconstnode(
p1^.resulttype^.size,pd);
{ p1 not needed !}
disposetree(p1);
end
else
begin
Must_be_valid:=false;
do_firstpass(p1);
if p1^.resulttype^.deftype<>objectdef then
begin
statement_syssym:=genordinalconstnode(
p1^.resulttype^.size,pd);
{ p1 not needed !}
disposetree(p1);
end
else
begin
statement_syssym:=geninlinenode(in_sizeof_x,p1);
end;
end;
end;
in_assigned_x : begin
consume(LKLAMMER);
in_args:=true;
p1:=expr;
Must_be_valid:=true;
do_firstpass(p1);
case p1^.resulttype^.deftype of
pointerdef,procvardef,
classrefdef:
;
objectdef:
if not(pobjectdef(p1^.resulttype)^.isclass) then
Message(parser_e_illegal_parameter_list);
else Message(parser_e_illegal_parameter_list);
end;
p2:=gencallparanode(p1,nil);
p2:=geninlinenode(in_assigned_x,p2);
consume(RKLAMMER);
pd:=booldef;
statement_syssym:=p2;
end;
in_ofs_x : begin
consume(LKLAMMER);
in_args:=true;
p1:=expr;
p1:=gensinglenode(addrn,p1);
Must_be_valid:=false;
do_firstpass(p1);
{ Ofs() returns a longint, not a pointer }
p1^.resulttype:=u32bitdef;
pd:=p1^.resulttype;
consume(RKLAMMER);
statement_syssym:=p1;
end;
in_seg_x : begin
consume(LKLAMMER);
in_args:=true;
p1:=expr;
do_firstpass(p1);
if p1^.location.loc<>LOC_REFERENCE then
Message(cg_e_illegal_expression);
p1:=genordinalconstnode(0,s32bitdef);
Must_be_valid:=false;
pd:=s32bitdef;
consume(RKLAMMER);
statement_syssym:=p1;
end;
in_high_x,
in_low_x : begin
consume(LKLAMMER);
in_args:=true;
p1:=expr;
do_firstpass(p1);
Must_be_valid:=false;
p2:=geninlinenode(l,p1);
consume(RKLAMMER);
pd:=s32bitdef;
statement_syssym:=p2;
end;
in_succ_x,
in_pred_x : begin
consume(LKLAMMER);
in_args:=true;
p1:=expr;
do_firstpass(p1);
Must_be_valid:=false;
p2:=geninlinenode(l,p1);
consume(RKLAMMER);
pd:=p1^.resulttype;
statement_syssym:=p2;
end;
in_inc_x,
in_dec_x : begin
consume(LKLAMMER);
in_args:=true;
p1:=expr;
p2:=gencallparanode(p1,nil);
Must_be_valid:=false;
if token=COMMA then
begin
consume(COMMA);
p1:=expr;
p2:=gencallparanode(p1,p2);
end;
statement_syssym:=geninlinenode(l,p2);
consume(RKLAMMER);
pd:=voiddef;
end;
in_concat_x : begin
consume(LKLAMMER);
in_args:=true;
p2:=nil;
while true do
begin
p1:=expr;
Must_be_valid:=true;
do_firstpass(p1);
if not((p1^.resulttype^.deftype=stringdef) or
((p1^.resulttype^.deftype=orddef) and
(porddef(p1^.resulttype)^.typ=uchar)
)
) then Message(parser_e_illegal_parameter_list);
if p2<>nil then
p2:=gennode(addn,p2,p1)
else p2:=p1;
if token=COMMA then
consume(COMMA)
else break;
end;
consume(RKLAMMER);
pd:=cstringdef;
statement_syssym:=p2;
end;
in_read_x,
in_readln_x : begin
if token=LKLAMMER then
begin
consume(LKLAMMER);
in_args:=true;
Must_be_valid:=false;
paras:=parse_paras(false,false);
consume(RKLAMMER);
end
else
paras:=nil;
pd:=voiddef;
p1:=geninlinenode(l,paras);
do_firstpass(p1);
statement_syssym := p1;
end;
in_write_x,
in_writeln_x : begin
if token=LKLAMMER then
begin
consume(LKLAMMER);
in_args:=true;
Must_be_valid:=true;
paras:=parse_paras(true,false);
consume(RKLAMMER);
end
else
paras:=nil;
pd:=voiddef;
p1 := geninlinenode(l,paras);
do_firstpass(p1);
statement_syssym := p1;
end;
in_str_x_string : begin
consume(LKLAMMER);
in_args:=true;
paras:=parse_paras(true,false);
consume(RKLAMMER);
p1 := geninlinenode(l,paras);
do_firstpass(p1);
statement_syssym := p1;
pd:=voiddef;
end;
{in_val_x : begin
consume(LKLAMMER);
paras:=parse_paras(false);
consume(RKLAMMER);
p1 := geninlinenode(l,paras);
do_firstpass(p1);
statement_syssym := p1;
pd:=voiddef;
end; }
else internalerror(15);
end;
in_args:=prev_in_args;
Must_be_valid:=Store_valid;
end;
{ reads the parameter for a subroutine call }
procedure do_proc_call(getaddr : boolean;var again : boolean;var p1:Ptree;var pd:Pdef);
var
prev_in_args : boolean;
prevafterassn : boolean;
begin
prev_in_args:=in_args;
prevafterassn:=afterassignment;
afterassignment:=false;
{ want we only determine the address of }
{ a subroutine }
if not(getaddr) then
begin
if token=LKLAMMER then
begin
consume(LKLAMMER);
in_args:=true;
p1^.left:=parse_paras(false,false);
consume(RKLAMMER);
end
else p1^.left:=nil;
{ do firstpass because we need the }
{ result type }
do_firstpass(p1);
end
else
begin
{ address operator @: }
p1^.left:=nil;
{ forget pd }
pd:=nil;
{ no postfix operators }
again:=false;
end;
pd:=p1^.resulttype;
in_args:=prev_in_args;
afterassignment:=prevafterassn;
end;
{ the ID token has to be consumed before calling this function }
procedure do_member_read(const sym : psym;var p1 : ptree;
var pd : pdef;var again : boolean);
var
static_name : string;
paras : ptree;
oldafterassignment,isclassref : boolean;
p2 : ptree;
begin
if sym=nil then
begin
Message(sym_e_id_no_member);
disposetree(p1);
p1:=genzeronode(errorn);
{ try to clean up }
pd:=generrordef;
again:=false;
end
else
begin
isclassref:=pd^.deftype=classrefdef;
{ we assume, that only procsyms and varsyms are in an object }
{ symbol table, for classes, properties are allowed }
case sym^.typ of
procsym:
begin
p1:=genmethodcallnode(pprocsym(sym),srsymtable,p1);
do_proc_call(false,again,p1,pd);
{ now we know the real method e.g. we can check for }
{ a class method }
if isclassref and ((p1^.procdefinition^.options and (poclassmethod or poconstructor))=0) then
Message(parser_e_only_class_methods_via_class_ref);
end;
varsym:
begin
if isclassref then
Message(parser_e_only_class_methods_via_class_ref);
if (sym^.properties and sp_static)<>0 then
begin
static_name:=lowercase(srsymtable^.name^)+'_'+sym^.name;
getsym(static_name,true);
disposetree(p1);
p1:=genloadnode(pvarsym(srsym),srsymtable);
end
else
p1:=gensubscriptnode(pvarsym(sym),p1);
pd:=pvarsym(sym)^.definition;
end;
propertysym:
begin
if isclassref then
Message(parser_e_only_class_methods_via_class_ref);
paras:=nil;
{ property parameters? }
if token=LECKKLAMMER then
begin
consume(LECKKLAMMER);
paras:=parse_paras(false,true);
consume(RECKKLAMMER);
end;
{ indexed property }
if (ppropertysym(sym)^.options and ppo_indexed)<>0 then
begin
p2:=genordinalconstnode(ppropertysym(sym)^.index,s32bitdef);
paras:=gencallparanode(p2,paras);
end;
if not(afterassignment) and not(in_args) then
begin
{ write property: }
{ no result }
pd:=voiddef;
if assigned(ppropertysym(sym)^.writeaccesssym) then
begin
if ppropertysym(sym)^.writeaccesssym^.typ=procsym then
begin
{ generate the method call }
p1:=genmethodcallnode(pprocsym(
ppropertysym(sym)^.writeaccesssym),
ppropertysym(sym)^.writeaccesssym^.owner,p1);
p1^.left:=paras;
{ to be on the save side }
oldafterassignment:=afterassignment;
consume(ASSIGNMENT);
{ read the expression }
afterassignment:=true;
p2:=expr;
p1^.left:=gencallparanode(p2,p1^.left);
afterassignment:=oldafterassignment;
end
else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then
begin
if assigned(paras) then
message(parser_e_no_paras_allowed);
p1:=gensubscriptnode(pvarsym(
ppropertysym(sym)^.readaccesssym),p1);
{ to be on the save side }
oldafterassignment:=afterassignment;
consume(ASSIGNMENT);
{ read the expression }
afterassignment:=true;
p2:=expr;
p1:=gennode(assignn,p1,p2);
afterassignment:=oldafterassignment;
end
else
begin
p1:=genzeronode(errorn);
Message(parser_e_no_procedure_to_access_property);
end;
end
else
begin
p1:=genzeronode(errorn);
Message(parser_e_no_procedure_to_access_property);
end;
end
else
begin
{ read property: }
pd:=ppropertysym(sym)^.proptype;
if assigned(ppropertysym(sym)^.readaccesssym) then
begin
if ppropertysym(sym)^.readaccesssym^.typ=varsym then
begin
if assigned(paras) then
message(parser_e_no_paras_allowed);
p1:=gensubscriptnode(pvarsym(
ppropertysym(sym)^.readaccesssym),p1);
pd:=pvarsym(sym)^.definition;
end
else if ppropertysym(sym)^.readaccesssym^.typ=procsym then
begin
{ generate the method call }
p1:=genmethodcallnode(pprocsym(
ppropertysym(sym)^.readaccesssym),
ppropertysym(sym)^.readaccesssym^.owner,p1);
{ insert paras }
p1^.left:=paras;
{ if we should be delphi compatible }
{ then force type conversion }
if cs_delphi2_compatible in aktswitches then
p1:=gentypeconvnode(p1,pd);
end
else
begin
p1:=genzeronode(errorn);
Message(sym_e_type_mismatch);
end;
end
else
begin
{ error, no function to read property }
p1:=genzeronode(errorn);
Message(parser_e_no_procedure_to_access_property);
end;
end;
end;
else internalerror(16);
end;
end;
end;
function factor(getaddr : boolean) : ptree;
var
l : longint;
p1,p2,p3 : ptree;
code : word;
pd,pd2 : pdef;
unit_specific, again : boolean;
static_name : string;
sym : pvarsym;
classh : pobjectdef;
d : bestreal;
constset : pconstset;
{ p1 and p2 must contain valid values }
procedure postfixoperators;
begin
while again do
begin
case token of
CARET:
begin
consume(CARET);
if pd^.deftype<>pointerdef then
begin
{ ^ as binary operator is a problem!!!! (FK) }
again:=false;
Message(cg_e_invalid_qualifier);
disposetree(p1);
p1:=genzeronode(errorn);
end
else
begin
p1:=gensinglenode(derefn,p1);
pd:=ppointerdef(pd)^.definition;
end;
end;
LECKKLAMMER : begin
consume(LECKKLAMMER);
repeat
if (pd^.deftype<>arraydef) and
(pd^.deftype<>stringdef) and
(pd^.deftype<>pointerdef) then
begin
Message(cg_e_invalid_qualifier);
disposetree(p1);
p1:=genzeronode(errorn);
end
else if (pd^.deftype=pointerdef) then
begin
p2:=expr;
p1:=gennode(vecn,p1,p2);
pd:=ppointerdef(pd)^.definition;
end
else
begin
p2:=expr;
{ support SEG:OFS for go32v2 Mem[] }
if (target_info.target=target_GO32V2) and
assigned(p1^.symtableentry) and
assigned(p1^.symtableentry^.owner^.name) and
(p1^.symtableentry^.owner^.name^='SYSTEM') and
((p1^.symtableentry^.name='MEM') or
(p1^.symtableentry^.name='MEMW') or
(p1^.symtableentry^.name='MEML')) then
begin
if (token=COLON) then
begin
consume(COLON);
p3:=gennode(muln,genordinalconstnode($10,s32bitdef),p2);
p2:=expr;
p2:=gennode(addn,p2,p3);
p1:=gennode(vecn,p1,p2);
p1^.memseg:=true;
p1^.memindex:=true;
end
else
begin
p1:=gennode(vecn,p1,p2);
p1^.memindex:=true;
end;
end
else
p1:=gennode(vecn,p1,p2);
if pd^.deftype=stringdef then
pd:=cchardef
else
pd:=parraydef(pd)^.definition;
end;
if token=COMMA then consume(COMMA)
else break;
until false;
consume(RECKKLAMMER);
end;
POINT : begin
consume(POINT);
case pd^.deftype of
recorddef:
begin
sym:=pvarsym(precdef(pd)^.symtable^.search(pattern));
consume(ID);
if sym=nil then
begin
Message(sym_e_illegal_field);
disposetree(p1);
p1:=genzeronode(errorn);
end
else
begin
p1:=gensubscriptnode(sym,p1);
pd:=sym^.definition;
end;
end;
classrefdef:
begin
classh:=pobjectdef(pclassrefdef(pd)^.definition);
sym:=nil;
while assigned(classh) do
begin
sym:=pvarsym(classh^.publicsyms^.search(pattern));
srsymtable:=classh^.publicsyms;
if assigned(sym) then
break;
classh:=classh^.childof;
end;
consume(ID);
do_member_read(sym,p1,pd,again);
end;
objectdef:
begin
classh:=pobjectdef(pd);
sym:=nil;
while assigned(classh) do
begin
sym:=pvarsym(classh^.publicsyms^.search(pattern));
srsymtable:=classh^.publicsyms;
if assigned(sym) then
break;
classh:=classh^.childof;
end;
consume(ID);
do_member_read(sym,p1,pd,again);
end;
pointerdef:
begin
if ppointerdef(pd)^.definition^.deftype
in [recorddef,objectdef,classrefdef] then
begin
Message(cg_e_invalid_qualifier);
{ exterror:=strpnew(' may be pointer deref ^ is missing');
error(invalid_qualifizier); }
Comment(V_hint,' may be pointer deref ^ is missing');
end
else
Message(cg_e_invalid_qualifier);
end
else
begin
Message(cg_e_invalid_qualifier);
disposetree(p1);
p1:=genzeronode(errorn);
end;
end;
end;
else
begin
{ is this a procedure variable ? }
if assigned(pd) then
begin
if (pd^.deftype=procvardef) then
begin
if getprocvar then
again:=false
else
if (token=LKLAMMER) or
((pprocvardef(pd)^.para1=nil) and
(token<>ASSIGNMENT) and (not in_args)) then
begin
{ do this in a strange way }
{ it's not a clean solution }
p2:=p1;
p1:=gencallnode(nil,
nil);
p1^.right:=p2;
p1^.unit_specific:=unit_specific;
if token=LKLAMMER then
begin
consume(LKLAMMER);
p1^.left:=parse_paras(false,false);
consume(RKLAMMER);
end;
pd:=pprocvardef(pd)^.retdef;
p1^.resulttype:=pd;
end
else again:=false;
p1^.resulttype:=pd;
end
else again:=false;
end
else again:=false;
end;
end;
end;
end;
procedure do_set(p : pconstset;pos : longint);
var
l : longint;
begin
if (pos>255) or
(pos<0) then
Message(parser_e_illegal_set_expr);
l:=pos div 8;
{ do we allow the same twice }
if (p^[l] and (1 shl (pos mod 8)))<>0 then
Message(parser_e_illegal_set_expr);
p^[l]:=p^[l] or (1 shl (pos mod 8));
end;
var
possible_error : boolean;
storesymtablestack : psymtable;
actprocsym : pprocsym;
begin
case token of
ID:
begin
{ allow post fix operators }
again:=true;
if (cs_delphi2_compatible in aktswitches) and
(pattern='RESULT') and
assigned(aktprocsym) and
(procinfo.retdef<>pdef(voiddef)) then
begin
consume(ID);
p1:=genzeronode(funcretn);
pd:=procinfo.retdef;
{$ifdef TEST_FUNCRET}
p1^.funcretprocinfo:=pointer(@procinfo);
p1^.retdef:=pd;
{$endif TEST_FUNCRET}
end
else
begin
getsym(pattern,true);
consume(ID);
{ is this an access to a function result ? }
if assigned(aktprocsym) and
((srsym^.name=aktprocsym^.name) or
((pvarsym(srsym)=opsym) and
((pprocdef(aktprocsym^.definition)^.options and pooperator)<>0))) and
(procinfo.retdef<>pdef(voiddef)) and
(token<>LKLAMMER) and
(not ((cs_tp_compatible in aktswitches) and
(afterassignment or in_args))) then
begin
p1:=genzeronode(funcretn);
pd:=procinfo.retdef;
{$ifdef TEST_FUNCRET}
p1^.funcretprocinfo:=pointer(@procinfo);
p1^.retdef:=pd;
{$endif TEST_FUNCRET}
end
else
{ else it's a normal symbol }
begin
if srsym^.typ=unitsym then
begin
consume(POINT);
getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
unit_specific:=true;
consume(ID);
end
else
unit_specific:=false;
if not assigned(srsym) then
Begin
p1:=genzeronode(errorn);
{ try to clean up }
pd:=generrordef;
end
else
case srsym^.typ of
absolutesym:
begin
p1:=genloadnode(pvarsym(srsym),srsymtable);
pd:=pabsolutesym(srsym)^.definition;
end;
varsym:
begin
{ are we in a class method ? }
if (srsymtable^.symtabletype=objectsymtable) and
assigned(aktprocsym) and
((aktprocsym^.definition^.options and poclassmethod)<>0) then
Message(parser_e_only_class_methods);
if (srsym^.properties and sp_static)<>0 then
begin
static_name:=lowercase(srsymtable^.name^)+'_'+srsym^.name;
getsym(static_name,true);
end;
p1:=genloadnode(pvarsym(srsym),srsymtable);
if pvarsym(srsym)^.is_valid=0 then
begin
p1^.is_first := true;
{ set special between first loaded
until checked in firstpass }
pvarsym(srsym)^.is_valid:=2;
end;
pd:=pvarsym(srsym)^.definition;
end;
typedconstsym:
begin
p1:=gentypedconstloadnode(ptypedconstsym(srsym),srsymtable);
pd:=ptypedconstsym(srsym)^.definition;
end;
syssym:
p1:=statement_syssym(psyssym(srsym)^.number,pd);
typesym:
begin
pd:=ptypesym(srsym)^.definition;
if token=LKLAMMER then
begin
consume(LKLAMMER);
p1:=expr;
consume(RKLAMMER);
p1:=gentypeconvnode(p1,pd);
p1^.explizit:=true;
end
else if (token=POINT) and
(pd^.deftype=objectdef) and
((pobjectdef(pd)^.options and oois_class)=0) then
begin
consume(POINT);
if assigned(procinfo._class) then
begin
if procinfo._class^.isrelated(pobjectdef(pd)) then
begin
p1:=genzeronode(typen);
p1^.resulttype:=pd;
srsymtable:=pobjectdef(pd)^.publicsyms;
sym:=pvarsym(srsymtable^.search(pattern));
consume(ID);
do_member_read(sym,p1,pd,again);
end
else
begin
Message(parser_e_no_super_class);
pd:=generrordef;
again:=false;
end;
end
else
begin
{ allows @TObject.Load }
{ also allows static methods and variables }
p1:=genzeronode(typen);
p1^.resulttype:=pd;
srsymtable:=pobjectdef(pd)^.publicsyms;
sym:=pvarsym(srsymtable^.search(pattern));
if not(getaddr) and
((sym^.properties and sp_static)=0) then
Message(sym_e_only_static_in_static)
else
begin
consume(ID);
do_member_read(sym,p1,pd,again);
end;
end
end
else
begin
{ class reference ? }
if (pd^.deftype=objectdef)
and ((pobjectdef(pd)^.options and oois_class)<>0) then
begin
p1:=genzeronode(typen);
p1^.resulttype:=pd;
pd:=new(pclassrefdef,init(pd));
p1:=gensinglenode(loadvmtn,p1);
p1^.resulttype:=pd;
end
else
begin
{ generate a type node }
{ (for typeof etc) }
p1:=genzeronode(typen);
p1^.resulttype:=pd;
pd:=voiddef;
end;
end;
end;
enumsym:
begin
p1:=genenumnode(penumsym(srsym));
pd:=p1^.resulttype;
end;
constsym:
begin
case pconstsym(srsym)^.consttype of
constint:
p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
conststring:
p1:=genstringconstnode(pstring(pconstsym(srsym)^.value)^);
constchar:
p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
constreal:
p1:=genrealconstnode(pdouble(pconstsym(srsym)^.value)^);
constbool:
p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
constseta:
p1:=gensetconstruktnode(pconstset(pconstsym(srsym)^.value),
psetdef(pconstsym(srsym)^.definition));
constord:
p1:=genordinalconstnode(pconstsym(srsym)^.value,
pconstsym(srsym)^.definition);
end;
pd:=p1^.resulttype;
end;
procsym:
begin
{ are we in a class method ? }
possible_error:=(srsymtable^.symtabletype=objectsymtable) and
assigned(aktprocsym) and
((aktprocsym^.definition^.options and poclassmethod)<>0);
p1:=gencallnode(pprocsym(srsym),srsymtable);
p1^.unit_specific:=unit_specific;
do_proc_call(getaddr,again,p1,pd);
if possible_error and
((p1^.procdefinition^.options and poclassmethod)=0) then
Message(parser_e_only_class_methods);
end;
propertysym:
begin
{ access to property in a method }
{ are we in a class method ? }
if (srsymtable^.symtabletype=objectsymtable) and
assigned(aktprocsym) and
((aktprocsym^.definition^.options and poclassmethod)<>0) then
Message(parser_e_only_class_methods);
{ !!!!! }
end;
errorsym:
begin
p1:=genzeronode(errorn);
pd:=generrordef;
if token=LKLAMMER then
begin
consume(LKLAMMER);
parse_paras(false,false);
consume(RKLAMMER);
end;
end;
else
begin
p1:=genzeronode(errorn);
pd:=generrordef;
Message(cg_e_illegal_expression);
end;
end; { end case }
end;
end;
{ handle post fix operators }
postfixoperators;
end;
_NEW : begin
consume(_NEW);
consume(LKLAMMER);
p1:=factor(false);
if p1^.treetype<>typen then
Message(sym_e_type_id_expected);
pd:=p1^.resulttype;
pd2:=pd;
if (pd^.deftype<>pointerdef) or
(ppointerdef(pd)^.definition^.deftype<>objectdef) then
begin
Message(parser_e_pointer_to_class_expected);
{ if an error occurs, read til the end of the new }
{ statement }
p1:=genzeronode(errorn);
l:=1;
while true do
begin
case token of
LKLAMMER : inc(l);
RKLAMMER : dec(l);
end;
consume(token);
if l=0 then
break;
end;
end
else
begin
disposetree(p1);
p1:=genzeronode(hnewn);
p1^.resulttype:=ppointerdef(pd)^.definition;
consume(COMMA);
afterassignment:=false;
{ determines the current object defintion }
classh:=pobjectdef(ppointerdef(pd)^.definition);
{ check for an abstract class }
if (classh^.options and oois_abstract)<>0 then
Message(sym_e_no_instance_of_abstract_object);
{ search the constructor also in the symbol tables of }
{ the parents }
{ no constructor found }
sym:=nil;
while assigned(classh) do
begin
sym:=pvarsym(classh^.publicsyms^.search(pattern));
srsymtable:=classh^.publicsyms;
if assigned(sym) then
break;
classh:=classh^.childof;
end;
consume(ID);
do_member_read(sym,p1,pd,again);
if (p1^.treetype<>calln) or
(assigned(p1^.procdefinition) and
((p1^.procdefinition^.options and poconstructor)=0)) then
Message(parser_e_expr_have_to_be_constructor_call);
p1:=gensinglenode(newn,p1);
{ set the resulttype }
p1^.resulttype:=pd2;
consume(RKLAMMER);
end;
end;
_SELF:
begin
again:=true;
consume(_SELF);
if not assigned(procinfo._class) then
begin
p1:=genzeronode(errorn);
pd:=generrordef;
again:=false;
Message(parser_e_self_not_in_method);
end
else
begin
if (aktprocsym^.definition^.options and poclassmethod)<>0 then
begin
{ self in class methods is a class reference type }
pd:=new(pclassrefdef,init(procinfo._class));
p1:=genselfnode(pd);
p1^.resulttype:=pd;
end
else
begin
p1:=genselfnode(procinfo._class);
p1^.resulttype:=procinfo._class;
end;
pd:=p1^.resulttype;
postfixoperators;
end;
end;
_INHERITED : begin
again:=true;
consume(_INHERITED);
if assigned(procinfo._class) then
begin
classh:=procinfo._class^.childof;
while assigned(classh) do
begin
srsymtable:=pobjectdef(classh)^.publicsyms;
sym:=pvarsym(srsymtable^.search(pattern));
if assigned(sym) then
begin
p1:=genzeronode(typen);
p1^.resulttype:=classh;
pd:=p1^.resulttype;
consume(ID);
do_member_read(sym,p1,pd,again);
break;
end;
classh:=classh^.childof;
end;
if classh=nil then
begin
Message1(sym_e_id_no_member,pattern);
again:=false;
pd:=generrordef;
p1:=genzeronode(errorn);
end;
end
else
Message(parser_e_generic_methods_only_in_methods);
postfixoperators;
end;
INTCONST : begin
valint(pattern,l,code);
if code<>0 then
begin
val(pattern,d,code);
if code<>0 then
begin
Message(cg_e_invalid_integer);
l:=1;
consume(INTCONST);
p1:=genordinalconstnode(l,s32bitdef);
end
else
begin
consume(INTCONST);
p1:=genrealconstnode(d);
end;
end
else
begin
consume(INTCONST);
p1:=genordinalconstnode(l,s32bitdef);
end;
end;
REALNUMBER : begin
val(pattern,d,code);
if code<>0 then
begin
Message(parser_e_error_in_real);
d:=1.0;
end;
consume(REALNUMBER);
p1:=genrealconstnode(d);
end;
{ FILE and STRING can be also a type cast }
_STRING:
begin
pd:=stringtype;
consume(LKLAMMER);
p1:=expr;
consume(RKLAMMER);
p1:=gentypeconvnode(p1,pd);
p1^.explizit:=true;
{ handle postfix operators here e.g. string(a)[10] }
again:=true;
postfixoperators;
end;
_FILE:
begin
pd:=cfiledef;
consume(_FILE);
consume(LKLAMMER);
p1:=expr;
consume(RKLAMMER);
p1:=gentypeconvnode(p1,pd);
p1^.explizit:=true;
{ handle postfix operators here e.g. string(a)[10] }
again:=true;
postfixoperators;
end;
CSTRING:
begin
p1:=genstringconstnode(pattern);
consume(CSTRING);
end;
CCHAR:
begin
p1:=genordinalconstnode(ord(pattern[1]),cchardef);
consume(CCHAR);
end;
KLAMMERAFFE : begin
consume(KLAMMERAFFE);
p1:=factor(true);
p1:=gensinglenode(addrn,p1);
end;
LKLAMMER : begin
consume(LKLAMMER);
p1:=expr;
consume(RKLAMMER);
{ it's not a good solution }
{ but (a+b)^ makes some problems }
case token of
CARET,POINT,LECKKLAMMER:
begin
{ we need the resulttype }
{ of the expression in pd }
do_firstpass(p1);
pd:=p1^.resulttype;
again:=true;
postfixoperators;
end;
end;
end;
LECKKLAMMER : begin
consume(LECKKLAMMER);
new(constset);
for l:=0 to 31 do
constset^[l]:=0;
p2:=nil;
pd:=nil;
if token<>RECKKLAMMER then
while true do
begin
p1:=expr;
do_firstpass(p1);
case p1^.treetype of
ordconstn : begin
if pd=nil then
pd:=p1^.resulttype;
if not(is_equal(pd,p1^.resulttype)) then
Message(parser_e_typeconflict_in_set)
else
do_set(constset,p1^.value);
disposetree(p1);
end;
rangen : begin
if pd=nil then
pd:=p1^.left^.resulttype;
if not(is_equal(pd,p1^.left^.resulttype)) then
Message(parser_e_typeconflict_in_set)
else
for l:=p1^.left^.value to p1^.right^.value do
do_set(constset,l);
disposetree(p1);
end;
stringconstn : begin
if pd=nil then
pd:=cchardef;
if not(is_equal(pd,cchardef)) then
Message(parser_e_typeconflict_in_set)
else
for l:=1 to length(pstring(p1^.values)^) do
do_set(constset,ord(pstring(p1^.values)^[l]));
disposetree(p1);
end;
else
begin
if pd=nil then
pd:=p1^.resulttype;
if not(is_equal(pd,p1^.resulttype)) then
Message(parser_e_typeconflict_in_set);
p2:=gennode(setelen,p1,p2);
end;
end;
if token=COMMA then
consume(COMMA)
else break;
end;
consume(RECKKLAMMER);
p1:=gensinglenode(setconstrn,p2);
p1^.resulttype:=new(psetdef,init(pd,255));
p1^.constset:=constset;
end;
PLUS : begin
consume(PLUS);
p1:=factor(false);
end;
MINUS : begin
consume(MINUS);
p1:=factor(false);
p1:=gensinglenode(umminusn,p1);
end;
_NOT : begin
consume(_NOT);
p1:=factor(false);
p1:=gensinglenode(notn,p1);
end;
_TRUE : begin
consume(_TRUE);
p1:=genordinalconstnode(1,booldef);
end;
_FALSE : begin
consume(_FALSE);
p1:=genordinalconstnode(0,booldef);
end;
_NIL : begin
consume(_NIL);
p1:=genzeronode(niln);
end;
else
begin
p1:=genzeronode(errorn);
consume(token);
Message(cg_e_illegal_expression);
end;
end;
factor:=p1;
end;
type Toperator_precedence=(opcompare,opaddition,opmultiply);
const tok2node:array[PLUS.._XOR] of Ttreetyp=
(addn,subn,muln,slashn,equaln,gtn,ltn,gten,lten,
isn,asn,inn,
nothingn,caretn,nothingn,unequaln,nothingn,
nothingn,nothingn,nothingn,nothingn,nothingn,
nothingn,nothingn,nothingn,nothingn,nothingn,
nothingn,nothingn,nothingn,nothingn,nothingn,
nothingn,andn,nothingn,nothingn,nothingn,
nothingn,nothingn,nothingn,nothingn,nothingn,
nothingn,nothingn,divn,nothingn,nothingn,
nothingn,nothingn,nothingn,nothingn,nothingn,
nothingn,nothingn,nothingn,nothingn,nothingn,
nothingn,nothingn,nothingn,nothingn,nothingn,
modn,nothingn,nothingn,nothingn,nothingn,
nothingn,nothingn,orn,
nothingn,nothingn,nothingn,nothingn,nothingn,
nothingn,nothingn,shln,shrn,
nothingn,nothingn,nothingn,nothingn,nothingn,
nothingn,nothingn,nothingn,nothingn,nothingn,
nothingn,xorn);
operator_levels:array[Toperator_precedence] of set of Ttoken=
([LT,LTE,GT,GTE,EQUAL,UNEQUAL,_IN,_IS],
[PLUS,MINUS,_OR,_XOR],
[CARET,SYMDIF,STAR,SLASH,_DIV,_MOD,_AND,_SHL,_SHR,_AS]);
function sub_expr(pred_level:Toperator_precedence):Ptree;
{Reads a subexpression while the operators are of the current precedence
level, or any higher level. Replaces the old term, simpl_expr and
simpl2_expr.}
var p1,p2:Ptree;
oldt:Ttoken;
begin
{ if pred_level=high(Toperator_precedence) then }
if pred_level=opmultiply then
p1:=factor(getprocvar)
else
p1:=sub_expr(succ(pred_level));
repeat
if token in operator_levels[pred_level] then
begin
oldt:=token;
consume(token);
{ if pred_level=high(Toperator_precedence) then }
if pred_level=opmultiply then
p2:=factor(getprocvar)
else
p2:=sub_expr(succ(pred_level));
p1:=gennode(tok2node[oldt],p1,p2);
end
else
break;
until false;
sub_expr:=p1;
end;
function expr : ptree;
var
p1,p2 : ptree;
oldafterassignment : boolean;
begin
oldafterassignment:=afterassignment;
p1:=sub_expr(opcompare);
if token in [ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
afterassignment:=true;
case token of
POINTPOINT : begin
consume(POINTPOINT);
p2:=sub_expr(opcompare);
p1:=gennode(rangen,p1,p2);
end;
ASSIGNMENT : begin
consume(ASSIGNMENT);
{ avoid a firstpass of a procedure if
it must be assigned to a procvar }
{ should be recursive for a:=b:=c !!! }
if (p1^.resulttype<>nil) and (p1^.resulttype^.deftype=procvardef) then
getprocvar:=true;
p2:=sub_expr(opcompare);
if getprocvar and (p2^.treetype=calln) then
begin
p2^.treetype:=loadn;
p2^.resulttype:=pprocsym(p2^.symtableprocentry)^.definition;
p2^.symtableentry:=p2^.symtableprocentry;
end;
getprocvar:=false;
p1:=gennode(assignn,p1,p2);
end;
{ this is the code for C like assignements }
{ from an improvement of Peter Schaefer }
_PLUSASN : begin
consume(_PLUSASN );
p2:=sub_expr(opcompare);
p1:=gennode(assignn,p1,gennode(addn,getcopy(p1),p2));
{ was first
p1:=gennode(assignn,p1,gennode(addn,p1,p2));
but disposetree assumes that we have a real
*** tree *** }
end;
_MINUSASN : begin
consume(_MINUSASN );
p2:=sub_expr(opcompare);
p1:=gennode(assignn,p1,gennode(subn,getcopy(p1),p2));
end;
_STARASN : begin
consume(_STARASN );
p2:=sub_expr(opcompare);
p1:=gennode(assignn,p1,gennode(muln,getcopy(p1),p2));
end;
_SLASHASN : begin
consume(_SLASHASN );
p2:=sub_expr(opcompare);
p1:=gennode(assignn,p1,gennode(slashn,getcopy(p1),p2));
end;
end;
afterassignment:=oldafterassignment;
expr:=p1;
end;
function get_intconst:longint;
{Reads an expression, tries to evalute it and check if it is an integer
constant. Then the constant is returned.}
var p:Ptree;
begin
p:=expr;
do_firstpass(p);
if (p^.treetype<>ordconstn) and
(p^.resulttype^.deftype=orddef) and
not (Porddef(p^.resulttype)^.typ in
[uvoid,uchar,bool8bit]) then
Message(cg_e_illegal_expression)
else
get_intconst:=p^.value;
disposetree(p);
end;
function get_stringconst:string;
{Reads an expression, tries to evaluate it and checks if it is a string
constant. Then the constant is returned.}
var p:Ptree;
begin
get_stringconst:='';
p:=expr;
do_firstpass(p);
if p^.treetype<>stringconstn then
if (p^.treetype=ordconstn) and
(p^.resulttype^.deftype=orddef) and
(Porddef(p^.resulttype)^.typ=uchar) then
get_stringconst:=char(p^.value)
else
Message(cg_e_illegal_expression)
else
get_stringconst:=p^.values^;
disposetree(p);
end;
end.
{
$Log: pexpr.pas,v $
Revision 1.2.2.1 1998/05/21 12:26:55 carl
* crash bugfix
Revision 1.2 1998/03/26 11:18:31 florian
- switch -Sa removed
- support of a:=b:=0 removed
Revision 1.1.1.1 1998/03/25 11:18:14 root
* Restored version
Revision 1.26 1998/03/24 21:48:33 florian
* just a couple of fixes applied:
- problem with fixed16 solved
- internalerror 10005 problem fixed
- patch for assembler reading
- small optimizer fix
- mem is now supported
Revision 1.25 1998/03/21 23:59:39 florian
* indexed properties fixed
* ppu i/o of properties fixed
* field can be also used for write access
* overriding of properties
Revision 1.24 1998/03/16 22:42:21 florian
* some fixes of Peter applied:
ofs problem, profiler support
Revision 1.23 1998/03/11 11:23:57 florian
* bug0081 and bug0109 fixed
Revision 1.22 1998/03/10 16:27:42 pierre
* better line info in stabs debug
* symtabletype and lexlevel separated into two fields of tsymtable
+ ifdef MAKELIB for direct library output, not complete
+ ifdef CHAINPROCSYMS for overloaded seach across units, not fully
working
+ ifdef TESTFUNCRET for setting func result in underfunction, not
working
Revision 1.21 1998/03/10 01:17:24 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Revision 1.20 1998/03/06 00:52:44 peter
* replaced all old messages from errore.msg, only ExtDebug and some
Comment() calls are left
* fixed options.pas
Revision 1.19 1998/03/02 01:49:02 peter
* renamed target_DOS to target_GO32V1
+ new verbose system, merged old errors and verbose units into one new
verbose.pas, so errors.pas is obsolete
Revision 1.18 1998/03/01 22:46:18 florian
+ some win95 linking stuff
* a couple of bugs fixed:
bug0055,bug0058,bug0059,bug0064,bug0072,bug0093,bug0095,bug0098
Revision 1.17 1998/02/27 21:24:06 florian
* dll support changed (dll name can be also a string contants)
Revision 1.16 1998/02/24 00:19:17 peter
* makefile works again (btw. linux does like any char after a \ )
* removed circular unit with assemble and files
* fixed a sigsegv in pexpr
* pmodule init unit/program is the almost the same, merged them
Revision 1.15 1998/02/13 10:35:24 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.14 1998/02/12 17:19:20 florian
* fixed to get remake3 work, but needs additional fixes (output, I don't like
also that aktswitches isn't a pointer)
Revision 1.13 1998/02/12 11:50:26 daniel
Yes! Finally! After three retries, my patch!
Changes:
Complete rewrite of psub.pas.
Added support for DLL's.
Compiler requires less memory.
Platform units for each platform.
Revision 1.12 1998/02/11 21:56:37 florian
* bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089
Revision 1.11 1998/02/01 22:41:11 florian
* clean up
+ system.assigned([class])
+ system.assigned([class of xxxx])
* first fixes of as and is-operator
Revision 1.10 1998/02/01 15:04:15 florian
* better error recovering
* some clean up
Revision 1.9 1998/01/30 21:27:05 carl
* partial bugfix #88, #89 and typeof and other inline functions
(these bugs have a deeper nesting level, and therefore i only fixed
the parser crashes - there is also a tree crash).
Revision 1.8 1998/01/26 17:31:01 florian
* stupid bug with self in class methods fixed
Revision 1.7 1998/01/25 22:29:02 florian
* a lot bug fixes on the DOM
Revision 1.6 1998/01/23 10:46:41 florian
* small problems with FCL object model fixed, objpas?.inc is compilable
Revision 1.5 1998/01/16 22:34:42 michael
* Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
in this compiler :)
Revision 1.4 1998/01/16 18:03:15 florian
* small bug fixes, some stuff of delphi styled constructores added
Revision 1.3 1998/01/13 23:11:14 florian
+ class methods
Revision 1.2 1998/01/09 09:09:59 michael
+ Initial implementation, second try
}
